home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / src / pl-pro.c < prev    next >
Encoding:
C/C++ Source or Header  |  1998-04-15  |  8.5 KB  |  360 lines
  1. /*  $Id: pl-pro.c,v 1.40 1998/04/15 15:17:07 jan Exp $
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: Support for virtual machine
  8. */
  9.  
  10. #ifdef SECURE_GC
  11. #define O_SECURE 1            /* include checkData() */
  12. #endif
  13. #include "pl-incl.h"
  14. #ifdef HAVE_MALLOC_H
  15. #include <malloc.h>
  16. #endif
  17.  
  18.         /********************************
  19.         *    CALLING THE INTERPRETER    *
  20.         *********************************/
  21.  
  22. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  23. Starts a new Prolog toplevel.  Resets I/O to point to the user and stops
  24. the debugger.  Restores I/O and debugger on exit.  The Prolog  predicate
  25. `$break' is called to actually built the break environment.
  26. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  27.  
  28. word
  29. pl_break()
  30. { fid_t cid = PL_open_foreign_frame();
  31.   term_t goal = PL_new_term_ref();
  32.   word rval;
  33.  
  34.   PL_put_atom_chars(goal, "$break");
  35.   rval = pl_break1(goal);
  36.   PL_discard_foreign_frame(cid);
  37.  
  38.   return rval;
  39. }
  40.  
  41.  
  42. word
  43. pl_break1(term_t goal)
  44. { extern int Input, Output;
  45.   bool rval;
  46.  
  47.   int  inSave    = Input;
  48.   int  outSave   = Output;
  49.   long skipSave  = debugstatus.skiplevel;
  50.   int  suspSave  = debugstatus.suspendTrace;
  51.   int  traceSave, debugSave;
  52.  
  53.   tracemode(FALSE, &traceSave);
  54.   debugmode(FALSE, &debugSave);
  55.  
  56.   Input = 0;
  57.   Output = 1;
  58.  
  59.   resetTracer();
  60.  
  61.   { fid_t cid = PL_open_foreign_frame();
  62.  
  63.     rval = callProlog(MODULE_user, goal, FALSE);
  64.  
  65.     PL_discard_foreign_frame(cid);
  66.   }
  67.  
  68.   debugstatus.suspendTrace = suspSave;
  69.   debugstatus.skiplevel    = skipSave;
  70.   tracemode(traceSave, NULL);
  71.   debugmode(debugSave, NULL);
  72.  
  73.   Output = outSave;
  74.   Input = inSave;
  75.  
  76.   return rval;
  77. }
  78.  
  79.  
  80. word
  81. pl_notrace1(term_t goal)
  82. { bool rval;
  83.  
  84.   long         skipSave  = debugstatus.skiplevel;
  85.   bool         traceSave = debugstatus.tracing;
  86.  
  87.   rval = callProlog(NULL, goal, FALSE);
  88.  
  89.   debugstatus.skiplevel    = skipSave;
  90.   debugstatus.tracing      = traceSave;
  91.  
  92.   return rval;
  93. }
  94.  
  95.  
  96.  
  97. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  98. Call a prolog goal from C. The argument must  be  an  instantiated  term
  99. like for the Prolog predicate call/1.
  100. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  101.  
  102. int
  103. callProlog(Module module, term_t goal, int debug)
  104. { term_t g = PL_new_term_ref();
  105.   functor_t fd;
  106.   Procedure proc;
  107.   int flags = (debug ? PL_Q_NORMAL : PL_Q_NODEBUG);
  108.  
  109.   PL_strip_module(goal, &module, g);
  110.   if ( !PL_get_functor(g, &fd) )
  111.     return warning("callProlog(): Illegal goal");
  112.   
  113.   proc = lookupProcedure(fd, module);
  114.   
  115.   { int arity = arityFunctor(fd);
  116.     term_t args = PL_new_term_refs(arity);
  117.     qid_t qid;
  118.     int n, rval;
  119.  
  120.     for(n=0; n<arity; n++)
  121.       PL_get_arg(n+1, g, args+n);
  122.  
  123.     qid  = PL_open_query(module, flags, proc, args);
  124.     rval = PL_next_solution(qid);
  125.     PL_cut_query(qid);
  126.  
  127.     return rval;
  128.   }
  129. }
  130.  
  131.  
  132. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  133. Bring the Prolog system itself to life.  Prolog  saves  the  C-stack  to
  134. enable  aborts.   pl_abort()  will  close  open  files, reset all clause
  135. references to `0' and finally long_jumps back to prolog().
  136. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  137.  
  138. static jmp_buf abort_context;        /* jmp buffer for abort() */
  139. static int can_abort;            /* embeded code can't abort */
  140.  
  141. word
  142. pl_abort()
  143. { if ( !can_abort )
  144.   { warning("Embedded system, cannot abort");
  145.     Halt(1);
  146.   }
  147.  
  148.   if ( GD->critical > 0 )        /* abort in critical region: delay */
  149.   { pl_notrace();
  150.     LD->aborted = TRUE;
  151.     succeed;
  152.   }
  153.  
  154.   if ( !trueFeature(READLINE_FEATURE) )
  155.     PopTty(&ttytab);
  156.   LD->outofstack = FALSE;
  157.   resetRead();
  158.   closeFiles(FALSE);
  159.   resetReferences();
  160. #ifdef O_PROFILE
  161.   pl_reset_profiler();
  162. #endif
  163.   resetStacks();
  164.   resetTracer();
  165.   resetSignals();
  166.   resetForeign();
  167.  
  168.   longjmp(abort_context, 1);
  169.   /*NOTREACHED*/
  170.   fail;
  171. }
  172.  
  173.  
  174. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  175. Initial entry point from C to start  the  Prolog  engine.   Saves  abort
  176. context,  clears  the  stack  and  finally  starts  the  virtual machine
  177. interpreter with the toplevel goal.
  178. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  179.  
  180. bool
  181. prolog(volatile atom_t goal)
  182. { bool rval;
  183.  
  184.   if ( setjmp(abort_context) != 0 )
  185.   { goal = ATOM_abort;
  186.   } else
  187.   { debugstatus.debugging = FALSE;
  188.   }
  189.  
  190.   emptyStacks();
  191.  
  192. #ifdef O_LIMIT_DEPTH
  193.   depth_limit   = (unsigned long)DEPTH_NO_LIMIT;
  194. #endif
  195.  
  196.   gc_status.blocked    = 0;
  197.   gc_status.requested  = FALSE;
  198. #if O_SHIFT_STACKS
  199.   shift_status.blocked = 0;
  200. #endif
  201.   LD->in_arithmetic    = 0;
  202.  
  203.   tracemode(FALSE, NULL);
  204.   debugmode(FALSE, NULL);
  205.   debugstatus.suspendTrace = 0;
  206.  
  207.   can_abort = TRUE;
  208.   { fid_t fid = PL_open_foreign_frame();
  209.     Procedure p = lookupProcedure(lookupFunctorDef(goal, 0), MODULE_system);
  210.  
  211.     for(;;)
  212.     { qid_t qid;
  213.       term_t except;
  214.  
  215.       *valTermRef(exception_printed) = 0;
  216.       qid = PL_open_query(MODULE_system, PL_Q_NORMAL, p, 0);
  217.       rval = PL_next_solution(qid);
  218.       if ( !rval && (except = PL_exception(qid)) )
  219.       { Word p1 = valTermRef(exception_printed);
  220.     Word p2 = valTermRef(except);
  221.     predicate_t pred = PL_predicate("unhandled_exception", 2, "$toplevel");
  222.     
  223.     deRef(p1);
  224.     deRef(p2);
  225.  
  226.     { fid_t fid2 = PL_open_foreign_frame();
  227.       term_t t0 = PL_new_term_refs(2);
  228.  
  229.       PL_put_atom(t0,   *p1 == *p2 ? ATOM_true : ATOM_false);
  230.       PL_put_term(t0+1, except);
  231.  
  232.       PL_call_predicate(NULL, FALSE, pred, t0);
  233.       PL_close_foreign_frame(fid2);
  234.       pl_notrace();
  235.     }
  236.     PL_close_query(qid);
  237.     continue;
  238.       }
  239.       PL_close_query(qid);
  240.       break;
  241.     }
  242.     PL_discard_foreign_frame(fid);
  243.   }
  244.   can_abort = FALSE;
  245.  
  246.   return rval;
  247. }
  248.  
  249. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  250. Cut (!) as called via the  meta-call  mechanism has no effect.
  251. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  252.  
  253. word
  254. pl_metacut(void)
  255. { succeed;
  256. }
  257.  
  258. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  259. Just for debugging now and then.
  260. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  261.  
  262. int
  263. trap_gdb()
  264. { return 0;
  265. }
  266.  
  267. #if O_SECURE || O_DEBUG || defined(O_MAINTENANCE)
  268.  
  269. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  270. checkData(p) verifies p points to valid  Prolog  data  and  generates  a
  271. system  error  otherwise.  The checks performed are much more rigid than
  272. those during normal execution.  Arity of terms is limited to  100  as  a
  273. kind of heuristic.
  274.  
  275. Note that we expect terms on the global stack.   This  is  true  in  the
  276. interpreter,  but  not everywere in the system (records use terms on the
  277. heap).
  278. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  279.  
  280. #define onGlobal(p) onStack(global, p)
  281. #define onLocal(p) onStack(local, p)
  282. #define onHeap(p) ((char *)p >= (char *)hBase && (char *)p <= (char *)hTop)
  283.  
  284. static void
  285. printk(char *fm, ...)
  286. { va_list args;
  287.  
  288.   va_start(args, fm);
  289.   Sfprintf(Serror, "[DATA INCONSISTENCY: ");
  290.   Svfprintf(Serror, fm, args);
  291.   Sfprintf(Serror, "]\n");
  292.   va_end(args);
  293.  
  294.   trap_gdb();
  295. }
  296.  
  297.  
  298. word
  299. checkData(Word p)
  300. { int arity; int n;
  301.   Word p2;
  302.  
  303.   while(isRef(*p))
  304.   { p2 = unRef(*p);
  305.     if ( p2 > p )
  306.       printk("Reference to higher address");
  307.     if ( !onLocal(p2) && !onGlobal(p2) )
  308.       printk("Illegal reference pointer at 0x%x --> 0x%x", p, p2);
  309.  
  310.     return checkData(p2);
  311.   }
  312.  
  313.   if ( isVar(*p) )
  314.     return 0x737473;            /* just a random number */
  315.  
  316.   if ( isTaggedInt(*p) )
  317.     return *p;
  318.  
  319.   if ( isIndirect(*p) )
  320.   { if ( storage(*p) != STG_GLOBAL )
  321.       printk("Indirect data not on global");
  322.     if ( isBignum(*p) )
  323.       return (word) valBignum(*p);
  324.     if ( isReal(*p) )
  325.       return (word) valReal(*p);
  326.     if ( isString(*p) )
  327.     { if ( sizeString(*p) != strlen(valString(*p)) )
  328.     printk("String has inconsistent length: 0x%x", *p);
  329.       return *addressIndirect(*p);
  330.     }
  331.     printk("Illegal indirect datatype");
  332.   }
  333.  
  334.   if ( isAtom(*p) )
  335.     return *p;
  336.                     /* now it should be a term */
  337.   if ( tag(*p) != TAG_COMPOUND ||
  338.        storage(*p) != STG_GLOBAL )
  339.     printk("Illegal term at: %p: 0x%x", p, *p);
  340.  
  341.   { word key = 0L;
  342.     Functor f = valueTerm(*p);
  343.  
  344.     if ( !onGlobal(f) )
  345.       printk("Term at %p not on global stack", f);
  346.       
  347.     if ( tag(f->definition) != TAG_ATOM ||
  348.          storage(f->definition) != STG_GLOBAL )
  349.       printk("Illegal term: 0x%x", *p);
  350.     arity = arityFunctor(f->definition);
  351.     if (arity <= 0 || arity > 100)
  352.       printk("Illegal arity");
  353.     for(n=0; n<arity; n++)
  354.       key += checkData(&f->arguments[n]);
  355.  
  356.     return key;
  357.   }
  358. }
  359. #endif /* TEST */
  360.